home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / x11 / x-select.el.z / x-select.el
Encoding:
Text File  |  1998-05-21  |  22.5 KB  |  642 lines
  1. ;; x-select.el --- Elisp interface to X Selections.
  2. ;; Copyright (C) 1990 Free Software Foundation, Inc.
  3. ;; Copyright (C) 1995 Sun Microsystems.
  4.  
  5. ;; This file is part of XEmacs.
  6.  
  7. ;; XEmacs is free software; you can redistribute it and/or modify it
  8. ;; under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; XEmacs is distributed in the hope that it will be useful, but
  13. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;; General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  19. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20. ;; Boston, MA 02111-1307, USA.
  21.  
  22. ;;; The selection code requires us to use certain symbols whose names are
  23. ;;; all upper-case; this may seem tasteless, but it makes there be a 1:1
  24. ;;; correspondence between these symbols and X Atoms (which are upcased).
  25.  
  26. ;;; Synched up with: FSF 19.30 (select.el).
  27.  
  28. ;;; Code:
  29.  
  30. (defvar x-selected-text-type
  31.   (if (featurep 'mule) '(COMPOUND_TEXT STRING) 'STRING)
  32.   "The type atom used to obtain selections from the X server.
  33. Can be either a valid X selection data type, or a list of such types.
  34. COMPOUND_TEXT and STRING are the most commonly used data types.
  35. If a list is provided, the types are tried in sequence until
  36. there is a successful conversion.")
  37.  
  38. (defun x-get-selection (&optional type data-type)
  39.   "Return the value of an X Windows selection.
  40. The argument TYPE (default `PRIMARY') says which selection, 
  41. and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
  42. says how to convert the data."
  43.   (or type (setq type 'PRIMARY))
  44.   (or data-type (setq data-type x-selected-text-type))
  45.   (let ((text
  46.      (if (consp data-type)
  47.          (condition-case err
  48.          (x-get-selection-internal type (car data-type))
  49.            (selection-conversion-error
  50.         (if (cdr data-type)
  51.             (x-get-selection type (cdr data-type))
  52.           (signal (car err) (cdr err)))))
  53.        (x-get-selection-internal type data-type))))
  54.     (when (and (consp text) (symbolp (car text)))
  55.       (setq text (cdr text)))
  56.     (when (not (stringp text))
  57.       (error "Selection is not a string: %S" text))
  58.     text))
  59.  
  60. (defun x-get-secondary-selection ()
  61.   "Return text selected from some X window."
  62.   (x-get-selection 'SECONDARY))
  63.  
  64. (defun x-get-clipboard ()
  65.   "Return text pasted to the clipboard."
  66.   (x-get-selection 'CLIPBOARD))
  67.  
  68.  
  69. (defvar primary-selection-extent nil
  70.   "The extent of the primary selection; don't use this.")
  71.  
  72. (defvar secondary-selection-extent nil
  73.   "The extent of the secondary selection; don't use this.")
  74.  
  75.  
  76. (defun x-select-make-extent-for-selection (selection previous-extent)
  77.   ;; Given a selection, this makes an extent in the buffer which holds that
  78.   ;; selection, for highlighting purposes.  If the selection isn't associated
  79.   ;; with a buffer, this does nothing.
  80.   (let ((buffer nil)
  81.     (valid (and (extentp previous-extent)
  82.             (extent-object previous-extent)
  83.             (buffer-live-p (extent-object previous-extent))))
  84.     start end)
  85.     (cond ((stringp selection)
  86.        ;; if we're selecting a string, lose the previous extent used
  87.        ;; to highlight the selection.
  88.        (setq valid nil))
  89.       ((consp selection)
  90.        (setq start (min (car selection) (cdr selection))
  91.          end (max (car selection) (cdr selection))
  92.          valid (and valid
  93.                 (eq (marker-buffer (car selection))
  94.                 (extent-object previous-extent)))
  95.          buffer (marker-buffer (car selection))))
  96.       ((extentp selection)
  97.        (setq start (extent-start-position selection)
  98.          end (extent-end-position selection)
  99.          valid (and valid
  100.                 (eq (extent-object selection)
  101.                 (extent-object previous-extent)))
  102.          buffer (extent-object selection)))
  103.       (t
  104.        (signal 'error (list "invalid selection" selection))))
  105.  
  106.     (if valid
  107.     nil
  108.       (condition-case ()
  109.       (if (listp previous-extent)
  110.           (mapcar 'delete-extent previous-extent)
  111.         (delete-extent previous-extent))
  112.     (error nil)))
  113.  
  114.     (if (not buffer)
  115.     ;; string case
  116.     nil
  117.       ;; normal case
  118.       (if valid
  119.       (set-extent-endpoints previous-extent start end)
  120.     (setq previous-extent (make-extent start end buffer))
  121.  
  122.     ;; Make the extent be closed on the right, which means that if
  123.     ;; characters are inserted exactly at the end of the extent, the
  124.     ;; extent will grow to cover them.  This is important for shell
  125.     ;; buffers - suppose one makes a selection, and one end is at
  126.     ;; point-max.  If the shell produces output, that marker will remain
  127.     ;; at point-max (its position will increase).  So it's important that
  128.     ;; the extent exhibit the same behavior, lest the region covered by
  129.     ;; the extent (the visual indication), and the region between point
  130.     ;; and mark (the actual selection value) become different!
  131.     (set-extent-property previous-extent 'end-open nil)
  132.  
  133.     (cond
  134.      (mouse-track-rectangle-p
  135.       (setq previous-extent (list previous-extent))
  136.       (default-mouse-track-next-move-rect start end previous-extent)
  137.       ))
  138.     previous-extent))))
  139.  
  140. ;; FSFmacs calls this `x-set-selection', and reverses the
  141. ;; arguments (duh ...).  This order is more logical.
  142. (defun x-own-selection (data &optional type)
  143.   "Make an X Windows selection of type TYPE and value DATA.
  144. The argument TYPE (default `PRIMARY') says which selection, 
  145. and DATA specifies the contents.  DATA may be a string,
  146. a symbol, an integer (or a cons of two integers or list of two integers).
  147.  
  148. The selection may also be a cons of two markers pointing to the same buffer,
  149. or an overlay.  In these cases, the selection is considered to be the text 
  150. between the markers *at whatever time the selection is examined*.
  151. Thus, editing done in the buffer after you specify the selection
  152. can alter the effective value of the selection.
  153.  
  154. The data may also be a vector of valid non-vector selection values.
  155.  
  156. Interactively, the text of the region is used as the selection value."
  157.   (interactive (if (not current-prefix-arg)
  158.            (list (read-string "Store text for pasting: "))
  159.          (list (substring (region-beginning) (region-end)))))
  160.   ;FSFmacs huh??  It says:
  161.   ;; "This is for temporary compatibility with pre-release Emacs 19."
  162.   ;(if (stringp type)
  163.   ;    (setq type (intern type)))
  164.   (or (x-valid-simple-selection-p data)
  165.       (and (vectorp data)
  166.        (let ((valid t)
  167.          (i (1- (length data))))
  168.          (while (>= i 0)
  169.            (or (x-valid-simple-selection-p (aref data i))
  170.            (setq valid nil))
  171.            (setq i (1- i)))
  172.          valid))
  173.       (signal 'error (list "invalid selection" data)))
  174.   (or type (setq type 'PRIMARY))
  175.   (if data
  176.       (x-own-selection-internal type data)
  177.     (x-disown-selection-internal type))
  178.   (cond ((eq type 'PRIMARY)
  179.      (setq primary-selection-extent
  180.            (x-select-make-extent-for-selection
  181.         data primary-selection-extent)))
  182.     ((eq type 'SECONDARY)
  183.      (setq secondary-selection-extent
  184.            (x-select-make-extent-for-selection
  185.         data secondary-selection-extent))))
  186.   (setq zmacs-region-stays t)
  187.   data)
  188.  
  189. (defun x-valid-simple-selection-p (data)
  190.   (or (stringp data)
  191.       ;FSFmacs huh?? (symbolp data)
  192.       (integerp data)
  193.       (and (consp data)
  194.        (integerp (car data))
  195.        (or (integerp (cdr data))
  196.            (and (consp (cdr data))
  197.             (integerp (car (cdr data))))))
  198.       (extentp data)
  199.       (and (consp data)
  200.        (markerp (car data))
  201.        (markerp (cdr data))
  202.        (marker-buffer (car data))
  203.        (marker-buffer (cdr data))
  204.        (eq (marker-buffer (car data))
  205.            (marker-buffer (cdr data)))
  206.        (buffer-live-p (marker-buffer (car data)))
  207.        (buffer-live-p (marker-buffer (cdr data))))))
  208.  
  209. (defun x-own-secondary-selection (selection &optional type)
  210.   "Make a secondary X Selection of the given argument.  The argument may be a 
  211. string or a cons of two markers (in which case the selection is considered to
  212. be the text between those markers)."
  213.   (interactive (if (not current-prefix-arg)
  214.            (list (read-string "Store text for pasting: "))
  215.          (list (cons ;; these need not be ordered.
  216.             (copy-marker (point-marker))
  217.             (copy-marker (mark-marker))))))
  218.   (x-own-selection selection 'SECONDARY))
  219.  
  220.  
  221. (defun x-own-clipboard (string)
  222.   "Paste the given string to the X Clipboard."
  223.   (x-own-selection string 'CLIPBOARD))
  224.  
  225.  
  226. (defun x-disown-selection (&optional secondary-p)
  227.   "Assuming we own the selection, disown it.  With an argument, discard the
  228. secondary selection instead of the primary selection."
  229.   (x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)))
  230.  
  231. (defun x-dehilight-selection (selection)
  232.   "for use as a value of `x-lost-selection-hooks'."
  233.   (cond ((eq selection 'PRIMARY)
  234.      (if primary-selection-extent
  235.          (let ((inhibit-quit t))
  236.            (if (consp primary-selection-extent)
  237.            (mapcar 'delete-extent primary-selection-extent)
  238.          (delete-extent primary-selection-extent))
  239.            (setq primary-selection-extent nil)))
  240.      (if zmacs-regions (zmacs-deactivate-region)))
  241.     ((eq selection 'SECONDARY)
  242.      (if secondary-selection-extent
  243.          (let ((inhibit-quit t))
  244.            (if (consp secondary-selection-extent)
  245.            (mapcar 'delete-extent secondary-selection-extent)
  246.          (delete-extent secondary-selection-extent))
  247.            (setq secondary-selection-extent nil)))))
  248.   nil)
  249.  
  250. (setq x-lost-selection-hooks 'x-dehilight-selection)
  251.  
  252. (defun x-notice-selection-requests (selection type successful)
  253.   "for possible use as the value of x-sent-selection-hooks."
  254.   (if (not successful)
  255.       (message "Selection request failed to convert %s to %s"
  256.            selection type)
  257.     (message "Sent selection %s as %s" selection type)))
  258.  
  259. (defun x-notice-selection-failures (selection type successful)
  260.   "for possible use as the value of x-sent-selection-hooks."
  261.   (or successful
  262.       (message "Selection request failed to convert %s to %s"
  263.            selection type)))
  264.  
  265. ;(setq x-sent-selection-hooks 'x-notice-selection-requests)
  266. ;(setq x-sent-selection-hooks 'x-notice-selection-failures)
  267.  
  268.  
  269. ;;; Selections in killed buffers
  270. ;;; this function is called by kill-buffer as if it were on the 
  271. ;;; kill-buffer-hook (though it isn't really).
  272.  
  273. (defun xselect-kill-buffer-hook ()
  274.   ;; Probably the right thing is to write a C function to return a list
  275.   ;; of the selections which emacs owns, since it could conceivably own
  276.   ;; a user-defined selection type that we've never heard of.
  277.   (xselect-kill-buffer-hook-1 'PRIMARY)
  278.   (xselect-kill-buffer-hook-1 'SECONDARY)
  279.   (xselect-kill-buffer-hook-1 'CLIPBOARD))
  280.  
  281. (defun xselect-kill-buffer-hook-1 (selection)
  282.   (let (value)
  283.     (if (and (x-selection-owner-p selection)
  284.          (setq value (x-get-selection-internal selection '_EMACS_INTERNAL))
  285.          ;; The _EMACS_INTERNAL selection type has a converter registered
  286.          ;; for it that does no translation.  This only works if emacs is
  287.          ;; requesting the selection from itself.  We could have done this
  288.          ;; by writing a C function to return the raw selection data, and
  289.          ;; that might be the right way to do this, but this was easy.
  290.          (or (and (consp value)
  291.               (markerp (car value))
  292.               (eq (current-buffer) (marker-buffer (car value))))
  293.          (and (extent-live-p value)
  294.               (eq (current-buffer) (extent-object value)))
  295.                  (and (extentp value) (not (extent-live-p value)))))
  296.     (x-disown-selection-internal selection))))
  297.  
  298.  
  299. ;;; Cut Buffer support
  300.  
  301. ;;; FSF name x-get-cut-buffer
  302. (defun x-get-cutbuffer (&optional which-one)
  303.   "Returns the value of one of the 8 X server cut buffers.  Optional arg
  304. WHICH-ONE should be a number from 0 to 7, defaulting to 0.
  305. Cut buffers are considered obsolete\; you should use selections instead.
  306. This function does nothing if support for cut buffers was not compiled
  307. into Emacs."
  308.   (and (fboundp 'x-get-cutbuffer-internal)
  309.        (x-get-cutbuffer-internal
  310.     (if which-one
  311.         (aref [CUT_BUFFER0 CUT_BUFFER1 CUT_BUFFER2 CUT_BUFFER3
  312.                    CUT_BUFFER4 CUT_BUFFER5 CUT_BUFFER6 CUT_BUFFER7]
  313.           which-one)
  314.       'CUT_BUFFER0))))
  315.  
  316. ;;; FSF name x-set-cut-buffer
  317. (defun x-store-cutbuffer (string &optional push)
  318.   "Store STRING into the X server's primary cut buffer.
  319. If PUSH is non-nil, also rotate the cut buffers:
  320. this means the previous value of the primary cut buffer moves the second
  321. cut buffer, and the second to the third, and so on (there are 8 buffers.)
  322. Cut buffers are considered obsolete; you should use selections instead.
  323. This function does nothing if support for cut buffers was not compiled
  324. into Emacs."
  325.   (and (fboundp 'x-store-cutbuffer-internal)
  326.        (progn
  327.      ;; Check the data type of STRING.
  328.      (substring string 0 0)
  329.      (if push
  330.          (x-rotate-cutbuffers-internal 1))
  331.      (x-store-cutbuffer-internal 'CUT_BUFFER0 string))))
  332.  
  333.  
  334. ;;; Random utility functions
  335.  
  336. (defun x-cut-copy-clear-internal (mode)
  337.   (or (memq mode '(cut copy clear)) (error "unkown mode %S" mode))
  338.   (or (x-selection-owner-p)
  339.       (error "emacs does not own the primary selection"))
  340.   (setq last-command nil)
  341.   (or primary-selection-extent
  342.       (error "the primary selection is not an extent?"))
  343.   (save-excursion
  344.     (let (rect-p b s e)
  345.       (cond
  346.        ((consp primary-selection-extent)
  347.     (setq rect-p t
  348.           b (extent-object (car primary-selection-extent))
  349.           s (extent-start-position (car primary-selection-extent))
  350.           e (extent-end-position (car (reverse primary-selection-extent)))))
  351.        (t
  352.     (setq rect-p nil
  353.           b (extent-object primary-selection-extent)
  354.           s (extent-start-position primary-selection-extent)
  355.           e (extent-end-position primary-selection-extent))))
  356.       (set-buffer b)
  357.       (cond ((memq mode '(cut copy))
  358.          (if rect-p
  359.          (progn
  360.            ;; why is killed-rectangle free?  Is it used somewhere?
  361.            ;; should it be defvarred?
  362.            (setq killed-rectangle (extract-rectangle s e))
  363.            (kill-new (mapconcat 'identity killed-rectangle "\n")))
  364.            (copy-region-as-kill s e))
  365.          ;; Maybe killing doesn't own clipboard.  Make sure it happens.
  366.          ;; This memq is kind of grody, because they might have done it
  367.          ;; some other way, but owning the clipboard twice in that case
  368.          ;; wouldn't actually hurt anything.
  369.          (or (and (consp kill-hooks) (memq 'x-own-clipboard kill-hooks))
  370.          (x-own-clipboard (car kill-ring)))))
  371.       (cond ((memq mode '(cut clear))
  372.          (if rect-p
  373.          (delete-rectangle s e)
  374.            (delete-region s e))))
  375.       (x-disown-selection nil)
  376.       )))
  377.  
  378. (defun x-copy-primary-selection ()
  379.   "Copy the selection to the Clipboard and the kill ring."
  380.   (interactive)
  381.   (x-cut-copy-clear-internal 'copy))
  382.  
  383. (defun x-kill-primary-selection ()
  384.   "Copy the selection to the Clipboard and the kill ring, then delete it."
  385.   (interactive "*")
  386.   (x-cut-copy-clear-internal 'cut))
  387.  
  388. (defun x-delete-primary-selection ()
  389.   "Delete the selection without copying it to the Clipboard or the kill ring."
  390.   (interactive "*")
  391.   (x-cut-copy-clear-internal 'clear))
  392.  
  393. (defun x-yank-clipboard-selection ()
  394.   "Insert the current Clipboard selection at point."
  395.   (interactive "*")
  396.   (setq last-command nil)
  397.   (setq this-command 'yank) ; so that yank-pop works.
  398.   (let ((clip (x-get-clipboard)))
  399.     (or clip (error "there is no clipboard selection"))
  400.     (push-mark)
  401.     (insert clip)))
  402.  
  403. ;;; Functions to convert the selection into various other selection types.
  404. ;;; Every selection type that emacs handles is implemented this way, except
  405. ;;; for TIMESTAMP, which is a special case.
  406.  
  407. (defun xselect-convert-to-text (selection type value)
  408.   (cond ((stringp value)
  409.      value)
  410.     ((extentp value)
  411.      (save-excursion
  412.        (set-buffer (extent-object value))
  413.        (save-restriction
  414.          (widen)
  415.          (buffer-substring (extent-start-position value)
  416.                    (extent-end-position value)))))
  417.     ((and (consp value)
  418.           (markerp (car value))
  419.           (markerp (cdr value)))
  420.      (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
  421.          (signal 'error
  422.              (list "markers must be in the same buffer"
  423.                (car value) (cdr value))))
  424.      (save-excursion
  425.        (set-buffer (or (marker-buffer (car value))
  426.                (error "selection is in a killed buffer")))
  427.        (save-restriction
  428.          (widen)
  429.          (buffer-substring (car value) (cdr value)))))
  430.     (t nil)))
  431.  
  432. (defun xselect-convert-to-string (selection type value)
  433.   (let ((outval (xselect-convert-to-text selection type value)))
  434.     ;; force the string to be not in Compound Text format.
  435.     (if (stringp outval)
  436.     (cons 'STRING outval)
  437.       outval)))
  438.  
  439. (defun xselect-convert-to-compound-text (selection type value)
  440.   ;; converts to compound text automatically
  441.   (xselect-convert-to-text selection type value))
  442.  
  443. (defun xselect-convert-to-length (selection type value)
  444.   (let ((value
  445.      (cond ((stringp value)
  446.         (length value))
  447.            ((extentp value)
  448.         (extent-length value))
  449.            ((and (consp value)
  450.              (markerp (car value))
  451.              (markerp (cdr value)))
  452.         (or (eq (marker-buffer (car value))
  453.             (marker-buffer (cdr value)))
  454.             (signal 'error
  455.                 (list "markers must be in the same buffer"
  456.                   (car value) (cdr value))))
  457.         (abs (- (car value) (cdr value)))))))
  458.     (if value ; force it to be in 32-bit format.
  459.     (cons (ash value -16) (logand value 65535))
  460.       nil)))
  461.  
  462. (defun xselect-convert-to-targets (selection type value)
  463.   ;; return a vector of atoms, but remove duplicates first.
  464.   (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
  465.      (rest all))
  466.     (while rest
  467.       (cond ((memq (car rest) (cdr rest))
  468.          (setcdr rest (delq (car rest) (cdr rest))))
  469.         ((eq (car (cdr rest)) '_EMACS_INTERNAL)  ; shh, it's a secret
  470.          (setcdr rest (cdr (cdr rest))))
  471.         (t
  472.          (setq rest (cdr rest)))))
  473.     (apply 'vector all)))
  474.  
  475. (defun xselect-convert-to-delete (selection type value)
  476.   (x-disown-selection-internal selection)
  477.   ;; A return value of nil means that we do not know how to do this conversion,
  478.   ;; and replies with an "error".  A return value of NULL means that we have
  479.   ;; done the conversion (and any side-effects) but have no value to return.
  480.   'NULL)
  481.  
  482. (defun xselect-convert-to-filename (selection type value)
  483.   (cond ((extentp value)
  484.      (buffer-file-name (or (extent-object value)
  485.                    (error "selection is in a killed buffer"))))
  486.     ((and (consp value)
  487.           (markerp (car value))
  488.           (markerp (cdr value)))
  489.      (buffer-file-name (or (marker-buffer (car value))
  490.                    (error "selection is in a killed buffer"))))
  491.     (t nil)))
  492.  
  493. (defun xselect-convert-to-charpos (selection type value)
  494.   (let (a b tmp)
  495.     (cond ((cond ((extentp value)
  496.           (setq a (extent-start-position value)
  497.             b (extent-end-position value)))
  498.          ((and (consp value)
  499.                (markerp (car value))
  500.                (markerp (cdr value)))
  501.           (setq a (car value)
  502.             b (cdr value))))
  503.        (setq a (1- a) b (1- b)) ; zero-based
  504.        (if (< b a) (setq tmp a a b b tmp))
  505.        (cons 'SPAN
  506.          (vector (cons (ash a -16) (logand a 65535))
  507.              (cons (ash b -16) (logand b 65535))))))))
  508.  
  509. (defun xselect-convert-to-lineno (selection type value)
  510.   (let (a b buf tmp)
  511.     (cond ((cond ((extentp value)
  512.           (setq buf (extent-object value)
  513.             a (extent-start-position value)
  514.             b (extent-end-position value)))
  515.          ((and (consp value)
  516.                (markerp (car value))
  517.                (markerp (cdr value)))
  518.           (setq a (marker-position (car value))
  519.             b (marker-position (cdr value))
  520.             buf (marker-buffer (car value)))))
  521.        (save-excursion
  522.          (set-buffer buf)
  523.          (save-restriction
  524.            (widen)
  525.            (goto-char a)
  526.            (beginning-of-line)
  527.            (setq a (1+ (count-lines 1 (point))))
  528.            (goto-char b)
  529.            (beginning-of-line)
  530.            (setq b (1+ (count-lines 1 (point))))))
  531.        (if (< b a) (setq tmp a a b b tmp))
  532.        (cons 'SPAN
  533.          (vector (cons (ash a -16) (logand a 65535))
  534.              (cons (ash b -16) (logand b 65535))))))))
  535.  
  536. (defun xselect-convert-to-colno (selection type value)
  537.   (let (a b buf tmp)
  538.     (cond ((cond ((extentp value)
  539.           (setq buf (extent-object value)
  540.             a (extent-start-position value)
  541.             b (extent-end-position value)))
  542.          ((and (consp value)
  543.                (markerp (car value))
  544.                (markerp (cdr value)))
  545.           (setq a (car value)
  546.             b (cdr value)
  547.             buf (marker-buffer a))))
  548.        (save-excursion
  549.          (set-buffer buf)
  550.          (goto-char a)
  551.          (setq a (current-column))
  552.          (goto-char b)
  553.          (setq b (current-column)))
  554.        (if (< b a) (setq tmp a a b b tmp))
  555.        (cons 'SPAN
  556.          (vector (cons (ash a -16) (logand a 65535))
  557.              (cons (ash b -16) (logand b 65535))))))))
  558.  
  559. (defun xselect-convert-to-sourceloc (selection type value)
  560.   (let (a b buf file-name tmp)
  561.     (cond ((cond ((extentp value)
  562.           (setq buf (or (extent-object value)
  563.                 (error "selection is in a killed buffer"))
  564.             a (extent-start-position value)
  565.             b (extent-end-position value)
  566.             file-name (buffer-file-name buf)))
  567.          ((and (consp value)
  568.                (markerp (car value))
  569.                (markerp (cdr value)))
  570.           (setq a (marker-position (car value))
  571.             b (marker-position (cdr value))
  572.             buf (or (marker-buffer (car value))
  573.                 (error "selection is in a killed buffer"))
  574.             file-name (buffer-file-name buf))))
  575.        (save-excursion
  576.          (set-buffer buf)
  577.          (save-restriction
  578.            (widen)
  579.            (goto-char a)
  580.            (beginning-of-line)
  581.            (setq a (1+ (count-lines 1 (point))))
  582.            (goto-char b)
  583.            (beginning-of-line)
  584.            (setq b (1+ (count-lines 1 (point))))))
  585.        (if (< b a) (setq tmp a a b b tmp))
  586.        (format "%s:%d" file-name a)))))
  587.  
  588. (defun xselect-convert-to-os (selection type size)
  589.   (symbol-name system-type))
  590.  
  591. (defun xselect-convert-to-host (selection type size)
  592.   (system-name))
  593.  
  594. (defun xselect-convert-to-user (selection type size)
  595.   (user-full-name))
  596.  
  597. (defun xselect-convert-to-class (selection type size)
  598.   x-emacs-application-class)
  599.  
  600. ;; We do not try to determine the name Emacs was invoked with,
  601. ;; because it is not clean for a program's behavior to depend on that.
  602. (defun xselect-convert-to-name (selection type size)
  603.   ;invocation-name
  604.   "xemacs")
  605.  
  606. (defun xselect-convert-to-integer (selection type value)
  607.   (and (integerp value)
  608.        (cons (ash value -16) (logand value 65535))))
  609.  
  610. (defun xselect-convert-to-atom (selection type value)
  611.   (and (symbolp value) value))
  612.  
  613. (defun xselect-convert-to-identity (selection type value) ; used internally
  614.   (vector value))
  615.  
  616. (setq selection-converter-alist
  617.       '((TEXT . xselect-convert-to-text)
  618.     (STRING . xselect-convert-to-string)
  619.     (COMPOUND_TEXT . xselect-convert-to-compound-text)
  620.     (TARGETS . xselect-convert-to-targets)
  621.     (LENGTH . xselect-convert-to-length)
  622.     (DELETE . xselect-convert-to-delete)
  623.     (FILE_NAME . xselect-convert-to-filename)
  624.     (CHARACTER_POSITION . xselect-convert-to-charpos)
  625.     (SOURCE_LOC . xselect-convert-to-sourceloc)
  626.     (LINE_NUMBER . xselect-convert-to-lineno)
  627.     (COLUMN_NUMBER . xselect-convert-to-colno)
  628.     (OWNER_OS . xselect-convert-to-os)
  629.     (HOST_NAME . xselect-convert-to-host)
  630.     (USER . xselect-convert-to-user)
  631.     (CLASS . xselect-convert-to-class)
  632.     (NAME . xselect-convert-to-name)
  633.     (ATOM . xselect-convert-to-atom)
  634.     (INTEGER . xselect-convert-to-integer)
  635.     (_EMACS_INTERNAL . xselect-convert-to-identity)
  636.     ))
  637.  
  638. ;FSFmacs (provide 'select)
  639.  
  640. ;;; x-select.el ends here.
  641.  
  642.